home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / generic / tclObj.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  59.5 KB  |  2,142 lines  |  [TEXT/CWIE]
  1. /* 
  2.  * tclObj.c --
  3.  *
  4.  *    This file contains Tcl object-related procedures that are used by
  5.  *     many Tcl commands.
  6.  *
  7.  * Copyright (c) 1995-1997 Sun Microsystems, Inc.
  8.  *
  9.  * See the file "license.terms" for information on usage and redistribution
  10.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11.  *
  12.  * SCCS: @(#) tclObj.c 1.45 97/07/07 18:26:00
  13.  */
  14.  
  15. #include "tclInt.h"
  16. #include "tclPort.h"
  17.  
  18. /*
  19.  * Table of all object types.
  20.  */
  21.  
  22. static Tcl_HashTable typeTable;
  23. static int typeTableInitialized = 0;    /* 0 means not yet initialized. */
  24.  
  25. /*
  26.  * Head of the list of free Tcl_Objs we maintain.
  27.  */
  28.  
  29. Tcl_Obj *tclFreeObjList = NULL;
  30.  
  31. /*
  32.  * Pointer to a heap-allocated string of length zero that the Tcl core uses
  33.  * as the value of an empty string representation for an object. This value
  34.  * is shared by all new objects allocated by Tcl_NewObj.
  35.  */
  36.  
  37. char *tclEmptyStringRep = NULL;
  38.  
  39. /*
  40.  * Count of the number of Tcl objects every allocated (by Tcl_NewObj) and
  41.  * freed (by TclFreeObj).
  42.  */
  43.  
  44. #ifdef TCL_COMPILE_STATS
  45. long tclObjsAlloced = 0;
  46. long tclObjsFreed = 0;
  47. #endif /* TCL_COMPILE_STATS */
  48.  
  49. /*
  50.  * Prototypes for procedures defined later in this file:
  51.  */
  52.  
  53. static void        DupBooleanInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
  54.                 Tcl_Obj *copyPtr));
  55. static void        DupDoubleInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
  56.                 Tcl_Obj *copyPtr));
  57. static void        DupIntInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
  58.                 Tcl_Obj *copyPtr));
  59. static void        FinalizeTypeTable _ANSI_ARGS_((void));
  60. static void        FinalizeFreeObjList _ANSI_ARGS_((void));
  61. static void        InitTypeTable _ANSI_ARGS_((void));
  62. static int        SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp,
  63.                 Tcl_Obj *objPtr));
  64. static int        SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp,
  65.                 Tcl_Obj *objPtr));
  66. static int        SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
  67.                 Tcl_Obj *objPtr));
  68. static void        UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr));
  69. static void        UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr));
  70. static void        UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr));
  71.  
  72. /*
  73.  * The structures below defines the Tcl object types defined in this file by
  74.  * means of procedures that can be invoked by generic object code. See also
  75.  * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager
  76.  * implementations.
  77.  */
  78.  
  79. Tcl_ObjType tclBooleanType = {
  80.     "boolean",                /* name */
  81.     (Tcl_FreeInternalRepProc *) NULL,   /* freeIntRepProc */
  82.     DupBooleanInternalRep,        /* dupIntRepProc */
  83.     UpdateStringOfBoolean,        /* updateStringProc */
  84.     SetBooleanFromAny            /* setFromAnyProc */
  85. };
  86.  
  87. Tcl_ObjType tclDoubleType = {
  88.     "double",                /* name */
  89.     (Tcl_FreeInternalRepProc *) NULL,   /* freeIntRepProc */
  90.     DupDoubleInternalRep,        /* dupIntRepProc */
  91.     UpdateStringOfDouble,        /* updateStringProc */
  92.     SetDoubleFromAny            /* setFromAnyProc */
  93. };
  94.  
  95. Tcl_ObjType tclIntType = {
  96.     "int",                /* name */
  97.     (Tcl_FreeInternalRepProc *) NULL,   /* freeIntRepProc */
  98.     DupIntInternalRep,                /* dupIntRepProc */
  99.     UpdateStringOfInt,            /* updateStringProc */
  100.     SetIntFromAny            /* setFromAnyProc */
  101. };
  102.  
  103. /*
  104.  *--------------------------------------------------------------
  105.  *
  106.  * InitTypeTable --
  107.  *
  108.  *    This procedure is invoked to perform once-only initialization of
  109.  *    the type table. It also registers the object types defined in 
  110.  *    this file.
  111.  *
  112.  * Results:
  113.  *    None.
  114.  *
  115.  * Side effects:
  116.  *    Initializes the table of defined object types "typeTable" with
  117.  *    builtin object types defined in this file. It also initializes the
  118.  *    value of tclEmptyStringRep, which points to the heap-allocated
  119.  *    string of length zero used as the string representation for
  120.  *    newly-created objects.
  121.  *
  122.  *--------------------------------------------------------------
  123.  */
  124.  
  125. static void
  126. InitTypeTable()
  127. {
  128.     typeTableInitialized = 1;
  129.  
  130.     Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
  131.     Tcl_RegisterObjType(&tclBooleanType);
  132.     Tcl_RegisterObjType(&tclDoubleType);
  133.     Tcl_RegisterObjType(&tclIntType);
  134.     Tcl_RegisterObjType(&tclStringType);
  135.     Tcl_RegisterObjType(&tclListType);
  136.     Tcl_RegisterObjType(&tclByteCodeType);
  137.  
  138.     tclEmptyStringRep = (char *) ckalloc((unsigned) 1);
  139.     tclEmptyStringRep[0] = '\0';
  140. }
  141.  
  142. /*
  143.  *----------------------------------------------------------------------
  144.  *
  145.  * FinalizeTypeTable --
  146.  *
  147.  *    This procedure is called by Tcl_Finalize after all exit handlers
  148.  *    have been run to free up storage associated with the table of Tcl
  149.  *    object types.
  150.  *
  151.  * Results:
  152.  *    None.
  153.  *
  154.  * Side effects:
  155.  *    Deletes all entries in the hash table of object types, "typeTable".
  156.  *    Then sets "typeTableInitialized" to 0 so that the Tcl type system
  157.  *    will be properly reinitialized if Tcl is restarted. Also deallocates
  158.  *    the storage for tclEmptyStringRep.
  159.  *
  160.  *----------------------------------------------------------------------
  161.  */
  162.  
  163. static void
  164. FinalizeTypeTable()
  165. {
  166.     if (typeTableInitialized) {
  167.         Tcl_DeleteHashTable(&typeTable);
  168.     ckfree(tclEmptyStringRep);
  169.         typeTableInitialized = 0;
  170.     }
  171. }
  172.  
  173. /*
  174.  *----------------------------------------------------------------------
  175.  *
  176.  * FinalizeFreeObjList --
  177.  *
  178.  *    Resets the free object list so it can later be reinitialized.
  179.  *
  180.  * Results:
  181.  *    None.
  182.  *
  183.  * Side effects:
  184.  *    Resets the value of tclFreeObjList.
  185.  *
  186.  *----------------------------------------------------------------------
  187.  */
  188.  
  189. static void
  190. FinalizeFreeObjList()
  191. {
  192.     tclFreeObjList = NULL;
  193. }
  194.  
  195. /*
  196.  *----------------------------------------------------------------------
  197.  *
  198.  * TclFinalizeCompExecEnv --
  199.  *
  200.  *    Clean up the compiler execution environment so it can later be
  201.  *    properly reinitialized.
  202.  *
  203.  * Results:
  204.  *    None.
  205.  *
  206.  * Side effects:
  207.  *    Cleans up the execution environment
  208.  *
  209.  *----------------------------------------------------------------------
  210.  */
  211.  
  212. void
  213. TclFinalizeCompExecEnv()
  214. {
  215.     FinalizeTypeTable();
  216.     FinalizeFreeObjList();
  217.     TclFinalizeExecEnv();
  218. }
  219.  
  220. /*
  221.  *--------------------------------------------------------------
  222.  *
  223.  * Tcl_RegisterObjType --
  224.  *
  225.  *    This procedure is called to register a new Tcl object type
  226.  *    in the table of all object types supported by Tcl.
  227.  *
  228.  * Results:
  229.  *    None.
  230.  *
  231.  * Side effects:
  232.  *    The type is registered in the Tcl type table. If there was already
  233.  *    a type with the same name as in typePtr, it is replaced with the
  234.  *    new type.
  235.  *
  236.  *--------------------------------------------------------------
  237.  */
  238.  
  239. void
  240. Tcl_RegisterObjType(typePtr)
  241.     Tcl_ObjType *typePtr;    /* Information about object type;
  242.                  * storage must be statically
  243.                  * allocated (must live forever). */
  244. {
  245.     register Tcl_HashEntry *hPtr;
  246.     int new;
  247.  
  248.     if (!typeTableInitialized) {
  249.     InitTypeTable();
  250.     }
  251.  
  252.     /*
  253.      * If there's already an object type with the given name, remove it.
  254.      */
  255.  
  256.     hPtr = Tcl_FindHashEntry(&typeTable, typePtr->name);
  257.     if (hPtr != (Tcl_HashEntry *) NULL) {
  258.         Tcl_DeleteHashEntry(hPtr);
  259.     }
  260.  
  261.     /*
  262.      * Now insert the new object type.
  263.      */
  264.  
  265.     hPtr = Tcl_CreateHashEntry(&typeTable, typePtr->name, &new);
  266.     if (new) {
  267.     Tcl_SetHashValue(hPtr, typePtr);
  268.     }
  269. }
  270.  
  271. /*
  272.  *----------------------------------------------------------------------
  273.  *
  274.  * Tcl_AppendAllObjTypes --
  275.  *
  276.  *    This procedure appends onto the argument object the name of each
  277.  *    object type as a list element. This includes the builtin object
  278.  *    types (e.g. int, list) as well as those added using
  279.  *    Tcl_CreateObjType. These names can be used, for example, with
  280.  *    Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType
  281.  *    structures.
  282.  *
  283.  * Results:
  284.  *    The return value is normally TCL_OK; in this case the object
  285.  *    referenced by objPtr has each type name appended to it. If an
  286.  *    error occurs, TCL_ERROR is returned and the interpreter's result
  287.  *    holds an error message.
  288.  *
  289.  * Side effects:
  290.  *    If necessary, the object referenced by objPtr is converted into
  291.  *    a list object.
  292.  *
  293.  *----------------------------------------------------------------------
  294.  */
  295.  
  296. int
  297. Tcl_AppendAllObjTypes(interp, objPtr)
  298.     Tcl_Interp *interp;        /* Interpreter used for error reporting. */
  299.     Tcl_Obj *objPtr;        /* Points to the Tcl object onto which the
  300.                  * name of each registered type is appended
  301.                  * as a list element. */
  302. {
  303.     register Tcl_HashEntry *hPtr;
  304.     Tcl_HashSearch search;
  305.     Tcl_ObjType *typePtr;
  306.     int result;
  307.  
  308.     if (!typeTableInitialized) {
  309.     InitTypeTable();
  310.     }
  311.  
  312.     /*
  313.      * This code assumes that types names do not contain embedded NULLs.
  314.      */
  315.  
  316.     for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
  317.         hPtr != NULL;  hPtr = Tcl_NextHashEntry(&search)) {
  318.         typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
  319.     result = Tcl_ListObjAppendElement(interp, objPtr,
  320.             Tcl_NewStringObj(typePtr->name, -1));
  321.     if (result == TCL_ERROR) {
  322.         return result;
  323.     }
  324.     }
  325.     return TCL_OK;
  326. }
  327.  
  328. /*
  329.  *----------------------------------------------------------------------
  330.  *
  331.  * Tcl_GetObjType --
  332.  *
  333.  *    This procedure looks up an object type by name.
  334.  *
  335.  * Results:
  336.  *    If an object type with name matching "typeName" is found, a pointer
  337.  *    to its Tcl_ObjType structure is returned; otherwise, NULL is
  338.  *    returned.
  339.  *
  340.  * Side effects:
  341.  *    None.
  342.  *
  343.  *----------------------------------------------------------------------
  344.  */
  345.  
  346. Tcl_ObjType *
  347. Tcl_GetObjType(typeName)
  348.     char *typeName;        /* Name of Tcl object type to look up. */
  349. {
  350.     register Tcl_HashEntry *hPtr;
  351.     Tcl_ObjType *typePtr;
  352.  
  353.     if (!typeTableInitialized) {
  354.     InitTypeTable();
  355.     }
  356.  
  357.     hPtr = Tcl_FindHashEntry(&typeTable, typeName);
  358.     if (hPtr != (Tcl_HashEntry *) NULL) {
  359.         typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
  360.     return typePtr;
  361.     }
  362.     return NULL;
  363. }
  364.  
  365. /*
  366.  *----------------------------------------------------------------------
  367.  *
  368.  * Tcl_ConvertToType --
  369.  *
  370.  *    Convert the Tcl object "objPtr" to have type "typePtr" if possible.
  371.  *
  372.  * Results:
  373.  *    The return value is TCL_OK on success and TCL_ERROR on failure. If
  374.  *    TCL_ERROR is returned, then the interpreter's result contains an
  375.  *    error message unless "interp" is NULL. Passing a NULL "interp"
  376.  *    allows this procedure to be used as a test whether the conversion
  377.  *    could be done (and in fact was done).
  378.  *
  379.  * Side effects:
  380.  *    Any internal representation for the old type is freed.
  381.  *
  382.  *----------------------------------------------------------------------
  383.  */
  384.  
  385. int
  386. Tcl_ConvertToType(interp, objPtr, typePtr)
  387.     Tcl_Interp *interp;        /* Used for error reporting if not NULL. */
  388.     Tcl_Obj *objPtr;        /* The object to convert. */
  389.     Tcl_ObjType *typePtr;    /* The target type. */
  390. {
  391.     if (objPtr->typePtr == typePtr) {
  392.     return TCL_OK;
  393.     }
  394.  
  395.     /*
  396.      * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal
  397.      * form as appropriate for the target type. This frees the old internal
  398.      * representation.
  399.      */
  400.  
  401.     return typePtr->setFromAnyProc(interp, objPtr);
  402. }
  403.  
  404. /*
  405.  *----------------------------------------------------------------------
  406.  *
  407.  * Tcl_NewObj --
  408.  *
  409.  *    This procedure is normally called when not debugging: i.e., when
  410.  *    TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote
  411.  *    the empty string. These objects have a NULL object type and NULL
  412.  *    string representation byte pointer. Type managers call this routine
  413.  *    to allocate new objects that they further initialize.
  414.  *
  415.  *    When TCL_MEM_DEBUG is defined, this procedure just returns the
  416.  *    result of calling the debugging version Tcl_DbNewObj.
  417.  *
  418.  * Results:
  419.  *    The result is a newly allocated object that represents the empty
  420.  *    string. The new object's typePtr is set NULL and its ref count
  421.  *    is set to 0.
  422.  *
  423.  * Side effects:
  424.  *    If compiling with TCL_COMPILE_STATS, this procedure increments
  425.  *    the global count of allocated objects (tclObjsAlloced).
  426.  *
  427.  *----------------------------------------------------------------------
  428.  */
  429.  
  430. #ifdef TCL_MEM_DEBUG
  431. #undef Tcl_NewObj
  432.  
  433. Tcl_Obj *
  434. Tcl_NewObj()
  435. {
  436.     return Tcl_DbNewObj("unknown", 0);
  437. }
  438.  
  439. #else /* if not TCL_MEM_DEBUG */
  440.  
  441. Tcl_Obj *
  442. Tcl_NewObj()
  443. {
  444.     register Tcl_Obj *objPtr;
  445.  
  446.     /*
  447.      * Allocate the object using the list of free Tcl_Objs we maintain.
  448.      */
  449.  
  450.     if (tclFreeObjList == NULL) {
  451.     TclAllocateFreeObjects();
  452.     }
  453.     objPtr = tclFreeObjList;
  454.     tclFreeObjList = (Tcl_Obj *) tclFreeObjList->internalRep.otherValuePtr;
  455.     
  456.     objPtr->refCount = 0;
  457.     objPtr->bytes    = tclEmptyStringRep;
  458.     objPtr->length   = 0;
  459.     objPtr->typePtr  = NULL;
  460. #ifdef TCL_COMPILE_STATS
  461.     tclObjsAlloced++;
  462. #endif /* TCL_COMPILE_STATS */
  463.     return objPtr;
  464. }
  465. #endif /* TCL_MEM_DEBUG */
  466.  
  467. /*
  468.  *----------------------------------------------------------------------
  469.  *
  470.  * Tcl_DbNewObj --
  471.  *
  472.  *    This procedure is normally called when debugging: i.e., when
  473.  *    TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the
  474.  *    empty string. It is the same as the Tcl_NewObj procedure above
  475.  *    except that it calls Tcl_DbCkalloc directly with the file name and
  476.  *    line number from its caller. This simplifies debugging since then
  477.  *    the checkmem command will report the correct file name and line
  478.  *    number when reporting objects that haven't been freed.
  479.  *
  480.  *    When TCL_MEM_DEBUG is not defined, this procedure just returns the
  481.  *    result of calling Tcl_NewObj.
  482.  *
  483.  * Results:
  484.  *    The result is a newly allocated that represents the empty string.
  485.  *    The new object's typePtr is set NULL and its ref count is set to 0.
  486.  *
  487.  * Side effects:
  488.  *    If compiling with TCL_COMPILE_STATS, this procedure increments
  489.  *    the global count of allocated objects (tclObjsAlloced).
  490.  *
  491.  *----------------------------------------------------------------------
  492.  */
  493.  
  494. #ifdef TCL_MEM_DEBUG
  495.  
  496. Tcl_Obj *
  497. Tcl_DbNewObj(file, line)
  498.     register char *file;    /* The name of the source file calling this
  499.                  * procedure; used for debugging. */
  500.     register int line;        /* Line number in the source file; used
  501.                  * for debugging. */
  502. {
  503.     register Tcl_Obj *objPtr;
  504.  
  505.     /*
  506.      * If debugging Tcl's memory usage, allocate the object using ckalloc.
  507.      * Otherwise, allocate it using the list of free Tcl_Objs we maintain.
  508.      */
  509.  
  510.     objPtr = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), file, line);
  511.     objPtr->refCount = 0;
  512.     objPtr->bytes    = tclEmptyStringRep;
  513.     objPtr->length   = 0;
  514.     objPtr->typePtr  = NULL;
  515. #ifdef TCL_COMPILE_STATS
  516.     tclObjsAlloced++;
  517. #endif /* TCL_COMPILE_STATS */
  518.     return objPtr;
  519. }
  520.  
  521. #else /* if not TCL_MEM_DEBUG */
  522.  
  523. Tcl_Obj *
  524. Tcl_DbNewObj(file, line)
  525.     char *file;            /* The name of the source file calling this
  526.                  * procedure; used for debugging. */
  527.     int line;            /* Line number in the source file; used
  528.                  * for debugging. */
  529. {
  530.     return Tcl_NewObj();
  531. }
  532. #endif /* TCL_MEM_DEBUG */
  533.  
  534. /*
  535.  *----------------------------------------------------------------------
  536.  *
  537.  * TclAllocateFreeObjects --
  538.  *
  539.  *    Procedure to allocate a number of free Tcl_Objs. This is done using
  540.  *    a single ckalloc to reduce the overhead for Tcl_Obj allocation.
  541.  *
  542.  * Results:
  543.  *    None.
  544.  *
  545.  * Side effects:
  546.  *    tclFreeObjList, the head of the list of free Tcl_Objs, is set to the
  547.  *    first of a number of free Tcl_Obj's linked together by their
  548.  *    internalRep.otherValuePtrs.
  549.  *
  550.  *----------------------------------------------------------------------
  551.  */
  552.  
  553. #define OBJS_TO_ALLOC_EACH_TIME 100
  554.  
  555. void
  556. TclAllocateFreeObjects()
  557. {
  558.     Tcl_Obj tmp[2];
  559.     size_t objSizePlusPadding =    /* NB: this assumes byte addressing. */
  560.     ((int)(&(tmp[1])) - (int)(&(tmp[0])));
  561.     size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding);
  562.     char *basePtr;
  563.     register Tcl_Obj *prevPtr, *objPtr;
  564.     register int i;
  565.  
  566.     basePtr = (char *) ckalloc(bytesToAlloc);
  567.     memset(basePtr, 0, bytesToAlloc);
  568.  
  569.     prevPtr = NULL;
  570.     objPtr = (Tcl_Obj *) basePtr;
  571.     for (i = 0;  i < OBJS_TO_ALLOC_EACH_TIME;  i++) {
  572.     objPtr->internalRep.otherValuePtr = (VOID *) prevPtr;
  573.     prevPtr = objPtr;
  574.     objPtr = (Tcl_Obj *) (((char *)objPtr) + objSizePlusPadding);
  575.     }
  576.     tclFreeObjList = prevPtr;
  577. }
  578. #undef OBJS_TO_ALLOC_EACH_TIME
  579.  
  580. /*
  581.  *----------------------------------------------------------------------
  582.  *
  583.  * TclFreeObj --
  584.  *
  585.  *    This procedure frees the memory associated with the argument
  586.  *    object. It is called by the tcl.h macro Tcl_DecrRefCount when an
  587.  *    object's ref count is zero. It is only "public" since it must
  588.  *    be callable by that macro wherever the macro is used. It should not
  589.  *    be directly called by clients.
  590.  *
  591.  * Results:
  592.  *    None.
  593.  *
  594.  * Side effects:
  595.  *    Deallocates the storage for the object's Tcl_Obj structure
  596.  *    after deallocating the string representation and calling the
  597.  *    type-specific Tcl_FreeInternalRepProc to deallocate the object's
  598.  *    internal representation. If compiling with TCL_COMPILE_STATS,
  599.  *    this procedure increments the global count of freed objects
  600.  *    (tclObjsFreed).
  601.  *
  602.  *----------------------------------------------------------------------
  603.  */
  604.  
  605. void
  606. TclFreeObj(objPtr)
  607.     register Tcl_Obj *objPtr;    /* The object to be freed. */
  608. {
  609.     register Tcl_ObjType *typePtr = objPtr->typePtr;
  610.     
  611. #ifdef TCL_MEM_DEBUG
  612.     if ((objPtr)->refCount < -1) {
  613.     panic("Reference count for %lx was negative", objPtr);
  614.     }
  615. #endif /* TCL_MEM_DEBUG */
  616.  
  617.     Tcl_InvalidateStringRep(objPtr);
  618.     if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
  619.     typePtr->freeIntRepProc(objPtr);
  620.     }
  621.  
  622.     /*
  623.      * If debugging Tcl's memory usage, deallocate the object using ckfree.
  624.      * Otherwise, deallocate it by adding it onto the list of free
  625.      * Tcl_Objs we maintain.
  626.      */
  627.     
  628. #ifdef TCL_MEM_DEBUG
  629.     ckfree((char *) objPtr);
  630. #else
  631.     objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList;
  632.     tclFreeObjList = objPtr;
  633. #endif /* TCL_MEM_DEBUG */
  634.  
  635. #ifdef TCL_COMPILE_STATS    
  636.     tclObjsFreed++;
  637. #endif /* TCL_COMPILE_STATS */    
  638. }
  639.  
  640. /*
  641.  *----------------------------------------------------------------------
  642.  *
  643.  * Tcl_DuplicateObj --
  644.  *
  645.  *    Create and return a new object that is a duplicate of the argument
  646.  *    object.
  647.  *
  648.  * Results:
  649.  *    The return value is a pointer to a newly created Tcl_Obj. This
  650.  *    object has reference count 0 and the same type, if any, as the
  651.  *    source object objPtr. Also:
  652.  *      1) If the source object has a valid string rep, we copy it;
  653.  *         otherwise, the duplicate's string rep is set NULL to mark
  654.  *         it invalid.
  655.  *      2) If the source object has an internal representation (i.e. its
  656.  *         typePtr is non-NULL), the new object's internal rep is set to
  657.  *         a copy; otherwise the new internal rep is marked invalid.
  658.  *
  659.  * Side effects:
  660.  *      What constitutes "copying" the internal representation depends on
  661.  *    the type. For example, if the argument object is a list,
  662.  *    the element objects it points to will not actually be copied but
  663.  *    will be shared with the duplicate list. That is, the ref counts of
  664.  *    the element objects will be incremented.
  665.  *
  666.  *----------------------------------------------------------------------
  667.  */
  668.  
  669. Tcl_Obj *
  670. Tcl_DuplicateObj(objPtr)
  671.     register Tcl_Obj *objPtr;        /* The object to duplicate. */
  672. {
  673.     register Tcl_ObjType *typePtr = objPtr->typePtr;
  674.     register Tcl_Obj *dupPtr;
  675.  
  676.     TclNewObj(dupPtr);
  677.  
  678.     if (objPtr->bytes == NULL) {
  679.     dupPtr->bytes = NULL;
  680.     } else if (objPtr->bytes != tclEmptyStringRep) {
  681.     int len = objPtr->length;
  682.     
  683.     dupPtr->bytes = (char *) ckalloc((unsigned) len+1);
  684.     if (len > 0) {
  685.         memcpy((VOID *) dupPtr->bytes, (VOID *) objPtr->bytes,
  686.            (unsigned) len);
  687.     }
  688.     dupPtr->bytes[len] = '\0';
  689.     dupPtr->length = len;
  690.     }
  691.     
  692.     if (typePtr != NULL) {
  693.     typePtr->dupIntRepProc(objPtr, dupPtr);
  694.     }
  695.     return dupPtr;
  696. }
  697.  
  698. /*
  699.  *----------------------------------------------------------------------
  700.  *
  701.  * Tcl_GetStringFromObj --
  702.  *
  703.  *    Returns the string representation's byte array pointer and length
  704.  *    for an object.
  705.  *
  706.  * Results:
  707.  *    Returns a pointer to the string representation of objPtr. If
  708.  *    lengthPtr isn't NULL, the length of the string representation is
  709.  *    stored at *lengthPtr. The byte array referenced by the returned
  710.  *    pointer must not be modified by the caller. Furthermore, the
  711.  *    caller must copy the bytes if they need to retain them since the
  712.  *    object's string rep can change as a result of other operations.
  713.  *
  714.  * Side effects:
  715.  *    May call the object's updateStringProc to update the string
  716.  *    representation from the internal representation.
  717.  *
  718.  *----------------------------------------------------------------------
  719.  */
  720.  
  721. char *
  722. Tcl_GetStringFromObj(objPtr, lengthPtr)
  723.     register Tcl_Obj *objPtr;    /* Object whose string rep byte pointer
  724.                  * should be returned. */
  725.     register int *lengthPtr;    /* If non-NULL, the location where the
  726.                  * string rep's byte array length should be
  727.                  * stored. If NULL, no length is stored. */
  728. {
  729.     if (objPtr->bytes != NULL) {
  730.     if (lengthPtr != NULL) {
  731.         *lengthPtr = objPtr->length;
  732.     }
  733.     return objPtr->bytes;
  734.     }
  735.  
  736.     objPtr->typePtr->updateStringProc(objPtr);
  737.     if (lengthPtr != NULL) {
  738.     *lengthPtr = objPtr->length;
  739.     }
  740.     return objPtr->bytes;
  741. }
  742.  
  743. /*
  744.  *----------------------------------------------------------------------
  745.  *
  746.  * Tcl_InvalidateStringRep --
  747.  *
  748.  *    This procedure is called to invalidate an object's string
  749.  *    representation. 
  750.  *
  751.  * Results:
  752.  *    None.
  753.  *
  754.  * Side effects:
  755.  *    Deallocates the storage for any old string representation, then
  756.  *    sets the string representation NULL to mark it invalid.
  757.  *
  758.  *----------------------------------------------------------------------
  759.  */
  760.  
  761. void
  762. Tcl_InvalidateStringRep(objPtr)
  763.      register Tcl_Obj *objPtr;    /* Object whose string rep byte pointer
  764.                  * should be freed. */
  765. {
  766.     if (objPtr->bytes != NULL) {
  767.     if (objPtr->bytes != tclEmptyStringRep) {
  768.         ckfree((char *) objPtr->bytes);
  769.     }
  770.     objPtr->bytes = NULL;
  771.     }
  772. }
  773.  
  774. /*
  775.  *----------------------------------------------------------------------
  776.  *
  777.  * Tcl_NewBooleanObj --
  778.  *
  779.  *    This procedure is normally called when not debugging: i.e., when
  780.  *    TCL_MEM_DEBUG is not defined. It creates a new boolean object and
  781.  *    initializes it from the argument boolean value. A nonzero
  782.  *    "boolValue" is coerced to 1.
  783.  *
  784.  *    When TCL_MEM_DEBUG is defined, this procedure just returns the
  785.  *    result of calling the debugging version Tcl_DbNewBooleanObj.
  786.  *
  787.  * Results:
  788.  *    The newly created object is returned. This object will have an
  789.  *    invalid string representation. The returned object has ref count 0.
  790.  *
  791.  * Side effects:
  792.  *    None.
  793.  *
  794.  *----------------------------------------------------------------------
  795.  */
  796.  
  797. #ifdef TCL_MEM_DEBUG
  798. #undef Tcl_NewBooleanObj
  799.  
  800. Tcl_Obj *
  801. Tcl_NewBooleanObj(boolValue)
  802.     register int boolValue;    /* Boolean used to initialize new object. */
  803. {
  804.     return Tcl_DbNewBooleanObj(boolValue, "unknown", 0);
  805. }
  806.  
  807. #else /* if not TCL_MEM_DEBUG */
  808.  
  809. Tcl_Obj *
  810. Tcl_NewBooleanObj(boolValue)
  811.     register int boolValue;    /* Boolean used to initialize new object. */
  812. {
  813.     register Tcl_Obj *objPtr;
  814.  
  815.     TclNewObj(objPtr);
  816.     objPtr->bytes = NULL;
  817.     
  818.     objPtr->internalRep.longValue = (boolValue? 1 : 0);
  819.     objPtr->typePtr = &tclBooleanType;
  820.     return objPtr;
  821. }
  822. #endif /* TCL_MEM_DEBUG */
  823.  
  824. /*
  825.  *----------------------------------------------------------------------
  826.  *
  827.  * Tcl_DbNewBooleanObj --
  828.  *
  829.  *    This procedure is normally called when debugging: i.e., when
  830.  *    TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the
  831.  *    same as the Tcl_NewBooleanObj procedure above except that it calls
  832.  *    Tcl_DbCkalloc directly with the file name and line number from its
  833.  *    caller. This simplifies debugging since then the checkmem command
  834.  *    will report the correct file name and line number when reporting
  835.  *    objects that haven't been freed.
  836.  *
  837.  *    When TCL_MEM_DEBUG is not defined, this procedure just returns the
  838.  *    result of calling Tcl_NewBooleanObj.
  839.  *
  840.  * Results:
  841.  *    The newly created object is returned. This object will have an
  842.  *    invalid string representation. The returned object has ref count 0.
  843.  *
  844.  * Side effects:
  845.  *    None.
  846.  *
  847.  *----------------------------------------------------------------------
  848.  */
  849.  
  850. #ifdef TCL_MEM_DEBUG
  851.  
  852. Tcl_Obj *
  853. Tcl_DbNewBooleanObj(boolValue, file, line)
  854.     register int boolValue;    /* Boolean used to initialize new object. */
  855.     char *file;            /* The name of the source file calling this
  856.                  * procedure; used for debugging. */
  857.     int line;            /* Line number in the source file; used
  858.                  * for debugging. */
  859. {
  860.     register Tcl_Obj *objPtr;
  861.  
  862.     TclDbNewObj(objPtr, file, line);
  863.     objPtr->bytes = NULL;
  864.     
  865.     objPtr->internalRep.longValue = (boolValue? 1 : 0);
  866.     objPtr->typePtr = &tclBooleanType;
  867.     return objPtr;
  868. }
  869.  
  870. #else /* if not TCL_MEM_DEBUG */
  871.  
  872. Tcl_Obj *
  873. Tcl_DbNewBooleanObj(boolValue, file, line)
  874.     register int boolValue;    /* Boolean used to initialize new object. */
  875.     char *file;            /* The name of the source file calling this
  876.                  * procedure; used for debugging. */
  877.     int line;            /* Line number in the source file; used
  878.                  * for debugging. */
  879. {
  880.     return Tcl_NewBooleanObj(boolValue);
  881. }
  882. #endif /* TCL_MEM_DEBUG */
  883.  
  884. /*
  885.  *----------------------------------------------------------------------
  886.  *
  887.  * Tcl_SetBooleanObj --
  888.  *
  889.  *    Modify an object to be a boolean object and to have the specified
  890.  *    boolean value. A nonzero "boolValue" is coerced to 1.
  891.  *
  892.  * Results:
  893.  *    None.
  894.  *
  895.  * Side effects:
  896.  *    The object's old string rep, if any, is freed. Also, any old
  897.  *    internal rep is freed.
  898.  *
  899.  *----------------------------------------------------------------------
  900.  */
  901.  
  902. void
  903. Tcl_SetBooleanObj(objPtr, boolValue)
  904.     register Tcl_Obj *objPtr;    /* Object whose internal rep to init. */
  905.     register int boolValue;    /* Boolean used to set object's value. */
  906. {
  907.     register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
  908.  
  909.     if (Tcl_IsShared(objPtr)) {
  910.     panic("Tcl_SetBooleanObj called with shared object");
  911.     }
  912.     
  913.     Tcl_InvalidateStringRep(objPtr);
  914.     if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
  915.     oldTypePtr->freeIntRepProc(objPtr);
  916.     }
  917.     
  918.     objPtr->internalRep.longValue = (boolValue? 1 : 0);
  919.     objPtr->typePtr = &tclBooleanType;
  920. }
  921.  
  922. /*
  923.  *----------------------------------------------------------------------
  924.  *
  925.  * Tcl_GetBooleanFromObj --
  926.  *
  927.  *    Attempt to return a boolean from the Tcl object "objPtr". If the
  928.  *    object is not already a boolean, an attempt will be made to convert
  929.  *    it to one.
  930.  *
  931.  * Results:
  932.  *    The return value is a standard Tcl object result. If an error occurs
  933.  *    during conversion, an error message is left in the interpreter's
  934.  *    result unless "interp" is NULL.
  935.  *
  936.  * Side effects:
  937.  *    If the object is not already a boolean, the conversion will free
  938.  *    any old internal representation. 
  939.  *
  940.  *----------------------------------------------------------------------
  941.  */
  942.  
  943. int
  944. Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
  945.     Tcl_Interp *interp;     /* Used for error reporting if not NULL. */
  946.     register Tcl_Obj *objPtr;    /* The object from which to get boolean. */
  947.     register int *boolPtr;    /* Place to store resulting boolean. */
  948. {
  949.     register int result;
  950.  
  951.     result = SetBooleanFromAny(interp, objPtr);
  952.     if (result == TCL_OK) {
  953.     *boolPtr = (int) objPtr->internalRep.longValue;
  954.     }
  955.     return result;
  956. }
  957.  
  958. /*
  959.  *----------------------------------------------------------------------
  960.  *
  961.  * DupBooleanInternalRep --
  962.  *
  963.  *    Initialize the internal representation of a boolean Tcl_Obj to a
  964.  *    copy of the internal representation of an existing boolean object. 
  965.  *
  966.  * Results:
  967.  *    None.
  968.  *
  969.  * Side effects:
  970.  *    "copyPtr"s internal rep is set to the boolean (an integer)
  971.  *    corresponding to "srcPtr"s internal rep.
  972.  *
  973.  *----------------------------------------------------------------------
  974.  */
  975.  
  976. static void
  977. DupBooleanInternalRep(srcPtr, copyPtr)
  978.     register Tcl_Obj *srcPtr;    /* Object with internal rep to copy. */
  979.     register Tcl_Obj *copyPtr;    /* Object with internal rep to set. */
  980. {
  981.     copyPtr->internalRep.longValue = srcPtr->internalRep.longValue;
  982.     copyPtr->typePtr = &tclBooleanType;
  983. }
  984.  
  985. /*
  986.  *----------------------------------------------------------------------
  987.  *
  988.  * SetBooleanFromAny --
  989.  *
  990.  *    Attempt to generate a boolean internal form for the Tcl object
  991.  *    "objPtr".
  992.  *
  993.  * Results:
  994.  *    The return value is a standard Tcl result. If an error occurs during
  995.  *    conversion, an error message is left in the interpreter's result
  996.  *    unless "interp" is NULL.
  997.  *
  998.  * Side effects:
  999.  *    If no error occurs, an integer 1 or 0 is stored as "objPtr"s
  1000.  *    internal representation and the type of "objPtr" is set to boolean.
  1001.  *
  1002.  *----------------------------------------------------------------------
  1003.  */
  1004.  
  1005. static int
  1006. SetBooleanFromAny(interp, objPtr)
  1007.     Tcl_Interp *interp;        /* Used for error reporting if not NULL. */
  1008.     register Tcl_Obj *objPtr;    /* The object to convert. */
  1009. {
  1010.     Tcl_ObjType *oldTypePtr = objPtr->typePtr;
  1011.     char *string, *end;
  1012.     register char c;
  1013.     char lowerCase[10];
  1014.     int newBool, length;
  1015.     register int i;
  1016.     double dbl;
  1017.  
  1018.     /*
  1019.      * Get the string representation. Make it up-to-date if necessary.
  1020.      */
  1021.  
  1022.     string = TclGetStringFromObj(objPtr, &length);
  1023.  
  1024.     /*
  1025.      * Copy the string converting its characters to lower case.
  1026.      */
  1027.  
  1028.     for (i = 0;  (i < 9) && (i < length);  i++) {
  1029.     c = string[i];
  1030.     if (isupper(UCHAR(c))) {
  1031.         c = (char) tolower(UCHAR(c));
  1032.     }
  1033.     lowerCase[i] = c;
  1034.     }
  1035.     lowerCase[i] = 0;
  1036.  
  1037.     /*
  1038.      * Parse the string as a boolean. We use an implementation here that
  1039.      * doesn't report errors in interp if interp is NULL.
  1040.      */
  1041.  
  1042.     c = lowerCase[0];
  1043.     if ((c == '0') && (lowerCase[1] == '\0')) {
  1044.     newBool = 0;
  1045.     } else if ((c == '1') && (lowerCase[1] == '\0')) {
  1046.     newBool = 1;
  1047.     } else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) {
  1048.     newBool = 1;
  1049.     } else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) {
  1050.     newBool = 0;
  1051.     } else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) {
  1052.     newBool = 1;
  1053.     } else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) {
  1054.     newBool = 0;
  1055.     } else if ((c == 'o') && (length >= 2)) {
  1056.     if (strncmp(lowerCase, "on", (size_t) length) == 0) {
  1057.         newBool = 1;
  1058.     } else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
  1059.         newBool = 0;
  1060.     } else {
  1061.         goto badBoolean;
  1062.     }
  1063.     } else {
  1064.         /*
  1065.          * Still might be a string containing the characters representing an
  1066.          * int or double that wasn't handled above. This would be a string
  1067.          * like "27" or "1.0" that is non-zero and not "1". Such a string
  1068.          * whould result in the boolean value true. We try converting to
  1069.          * double. If that succeeds and the resulting double is non-zero, we
  1070.          * have a "true". Note that numbers can't have embedded NULLs.
  1071.      */
  1072.  
  1073.     dbl = strtod(string, &end);
  1074.     if (end == string) {
  1075.         goto badBoolean;
  1076.     }
  1077.  
  1078.     /*
  1079.      * Make sure the string has no garbage after the end of the double.
  1080.      */
  1081.     
  1082.     while ((end < (string+length)) && isspace(UCHAR(*end))) {
  1083.         end++;
  1084.     }
  1085.     if (end != (string+length)) {
  1086.         goto badBoolean;
  1087.     }
  1088.     newBool = (dbl != 0.0);
  1089.     }
  1090.  
  1091.     /*
  1092.      * Free the old internalRep before setting the new one. We do this as
  1093.      * late as possible to allow the conversion code, in particular
  1094.      * Tcl_GetStringFromObj, to use that old internalRep.
  1095.      */
  1096.  
  1097.     if ((oldTypePtr != NULL) &&    (oldTypePtr->freeIntRepProc != NULL)) {
  1098.     oldTypePtr->freeIntRepProc(objPtr);
  1099.     }
  1100.  
  1101.     objPtr->internalRep.longValue = newBool;
  1102.     objPtr->typePtr = &tclBooleanType;
  1103.     return TCL_OK;
  1104.  
  1105.     badBoolean:
  1106.     if (interp != NULL) {
  1107.     /*
  1108.      * Must copy string before resetting the result in case a caller
  1109.      * is trying to convert the interpreter's result to a boolean.
  1110.      */
  1111.     
  1112.     char buf[100];
  1113.     sprintf(buf, "expected boolean value but got \"%.50s\"", string);
  1114.     Tcl_ResetResult(interp);
  1115.     Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
  1116.     }
  1117.     return TCL_ERROR;
  1118. }
  1119.  
  1120. /*
  1121.  *----------------------------------------------------------------------
  1122.  *
  1123.  * UpdateStringOfBoolean --
  1124.  *
  1125.  *    Update the string representation for a boolean object.
  1126.  *    Note: This procedure does not free an existing old string rep
  1127.  *    so storage will be lost if this has not already been done. 
  1128.  *
  1129.  * Results:
  1130.  *    None.
  1131.  *
  1132.  * Side effects:
  1133.  *    The object's string is set to a valid string that results from
  1134.  *    the boolean-to-string conversion.
  1135.  *
  1136.  *----------------------------------------------------------------------
  1137.  */
  1138.  
  1139. static void
  1140. UpdateStringOfBoolean(objPtr)
  1141.     register Tcl_Obj *objPtr;    /* Int object whose string rep to update. */
  1142. {
  1143.     char *s = ckalloc((unsigned) 2);
  1144.     
  1145.     s[0] = (char) (objPtr->internalRep.longValue? '1' : '0');
  1146.     s[1] = '\0';
  1147.     objPtr->bytes = s;
  1148.     objPtr->length = 1;
  1149. }
  1150.  
  1151. /*
  1152.  *----------------------------------------------------------------------
  1153.  *
  1154.  * Tcl_NewDoubleObj --
  1155.  *
  1156.  *    This procedure is normally called when not debugging: i.e., when
  1157.  *    TCL_MEM_DEBUG is not defined. It creates a new double object and
  1158.  *    initializes it from the argument double value.
  1159.  *
  1160.  *    When TCL_MEM_DEBUG is defined, this procedure just returns the
  1161.  *    result of calling the debugging version Tcl_DbNewDoubleObj.
  1162.  *
  1163.  * Results:
  1164.  *    The newly created object is returned. This object will have an
  1165.  *    invalid string representation. The returned object has ref count 0.
  1166.  *
  1167.  * Side effects:
  1168.  *    None.
  1169.  *
  1170.  *----------------------------------------------------------------------
  1171.  */
  1172.  
  1173. #ifdef TCL_MEM_DEBUG
  1174. #undef Tcl_NewDoubleObj
  1175.  
  1176. Tcl_Obj *
  1177. Tcl_NewDoubleObj(dblValue)
  1178.     register double dblValue;    /* Double used to initialize the object. */
  1179. {
  1180.     return Tcl_DbNewDoubleObj(dblValue, "unknown", 0);
  1181. }
  1182.  
  1183. #else /* if not TCL_MEM_DEBUG */
  1184.  
  1185. Tcl_Obj *
  1186. Tcl_NewDoubleObj(dblValue)
  1187.     register double dblValue;    /* Double used to initialize the object. */
  1188. {
  1189.     register Tcl_Obj *objPtr;
  1190.  
  1191.     TclNewObj(objPtr);
  1192.     objPtr->bytes = NULL;
  1193.     
  1194.     objPtr->internalRep.doubleValue = dblValue;
  1195.     objPtr->typePtr = &tclDoubleType;
  1196.     return objPtr;
  1197. }
  1198. #endif /* if TCL_MEM_DEBUG */
  1199.  
  1200. /*
  1201.  *----------------------------------------------------------------------
  1202.  *
  1203.  * Tcl_DbNewDoubleObj --
  1204.  *
  1205.  *    This procedure is normally called when debugging: i.e., when
  1206.  *    TCL_MEM_DEBUG is defined. It creates new double objects. It is the
  1207.  *    same as the Tcl_NewDoubleObj procedure above except that it calls
  1208.  *    Tcl_DbCkalloc directly with the file name and line number from its
  1209.  *    caller. This simplifies debugging since then the checkmem command
  1210.  *    will report the correct file name and line number when reporting
  1211.  *    objects that haven't been freed.
  1212.  *
  1213.  *    When TCL_MEM_DEBUG is not defined, this procedure just returns the
  1214.  *    result of calling Tcl_NewDoubleObj.
  1215.  *
  1216.  * Results:
  1217.  *    The newly created object is returned. This object will have an
  1218.  *    invalid string representation. The returned object has ref count 0.
  1219.  *
  1220.  * Side effects:
  1221.  *    None.
  1222.  *
  1223.  *----------------------------------------------------------------------
  1224.  */
  1225.  
  1226. #ifdef TCL_MEM_DEBUG
  1227.  
  1228. Tcl_Obj *
  1229. Tcl_DbNewDoubleObj(dblValue, file, line)
  1230.     register double dblValue;    /* Double used to initialize the object. */
  1231.     char *file;            /* The name of the source file calling this
  1232.                  * procedure; used for debugging. */
  1233.     int line;            /* Line number in the source file; used
  1234.                  * for debugging. */
  1235. {
  1236.     register Tcl_Obj *objPtr;
  1237.  
  1238.     TclDbNewObj(objPtr, file, line);
  1239.     objPtr->bytes = NULL;
  1240.     
  1241.     objPtr->internalRep.doubleValue = dblValue;
  1242.     objPtr->typePtr = &tclDoubleType;
  1243.     return objPtr;
  1244. }
  1245.  
  1246. #else /* if not TCL_MEM_DEBUG */
  1247.  
  1248. Tcl_Obj *
  1249. Tcl_DbNewDoubleObj(dblValue, file, line)
  1250.     register double dblValue;    /* Double used to initialize the object. */
  1251.     char *file;            /* The name of the source file calling this
  1252.                  * procedure; used for debugging. */
  1253.     int line;            /* Line number in the source file; used
  1254.                  * for debugging. */
  1255. {
  1256.     return Tcl_NewDoubleObj(dblValue);
  1257. }
  1258. #endif /* TCL_MEM_DEBUG */
  1259.  
  1260. /*
  1261.  *----------------------------------------------------------------------
  1262.  *
  1263.  * Tcl_SetDoubleObj --
  1264.  *
  1265.  *    Modify an object to be a double object and to have the specified
  1266.  *    double value.
  1267.  *
  1268.  * Results:
  1269.  *    None.
  1270.  *
  1271.  * Side effects:
  1272.  *    The object's old string rep, if any, is freed. Also, any old
  1273.  *    internal rep is freed.
  1274.  *
  1275.  *----------------------------------------------------------------------
  1276.  */
  1277.  
  1278. void
  1279. Tcl_SetDoubleObj(objPtr, dblValue)
  1280.     register Tcl_Obj *objPtr;    /* Object whose internal rep to init. */
  1281.     register double dblValue;    /* Double used to set the object's value. */
  1282. {
  1283.     register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
  1284.  
  1285.     if (Tcl_IsShared(objPtr)) {
  1286.     panic("Tcl_SetDoubleObj called with shared object");
  1287.     }
  1288.  
  1289.     Tcl_InvalidateStringRep(objPtr);
  1290.     if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
  1291.     oldTypePtr->freeIntRepProc(objPtr);
  1292.     }
  1293.     
  1294.     objPtr->internalRep.doubleValue = dblValue;
  1295.     objPtr->typePtr = &tclDoubleType;
  1296. }
  1297.  
  1298. /*
  1299.  *----------------------------------------------------------------------
  1300.  *
  1301.  * Tcl_GetDoubleFromObj --
  1302.  *
  1303.  *    Attempt to return a double from the Tcl object "objPtr". If the
  1304.  *    object is not already a double, an attempt will be made to convert
  1305.  *    it to one.
  1306.  *
  1307.  * Results:
  1308.  *    The return value is a standard Tcl object result. If an error occurs
  1309.  *    during conversion, an error message is left in the interpreter's
  1310.  *    result unless "interp" is NULL.
  1311.  *
  1312.  * Side effects:
  1313.  *    If the object is not already a double, the conversion will free
  1314.  *    any old internal representation.
  1315.  *
  1316.  *----------------------------------------------------------------------
  1317.  */
  1318.  
  1319. int
  1320. Tcl_GetDoubleFromObj(interp, objPtr, dblPtr)
  1321.     Tcl_Interp *interp;     /* Used for error reporting if not NULL. */
  1322.     register Tcl_Obj *objPtr;    /* The object from which to get a double. */
  1323.     register double *dblPtr;    /* Place to store resulting double. */
  1324. {
  1325.     register int result;
  1326.     
  1327.     if (objPtr->typePtr == &tclDoubleType) {
  1328.     *dblPtr = objPtr->internalRep.doubleValue;
  1329.     return TCL_OK;
  1330.     }
  1331.  
  1332.     result = SetDoubleFromAny(interp, objPtr);
  1333.     if (result == TCL_OK) {
  1334.     *dblPtr = objPtr->internalRep.doubleValue;
  1335.     }
  1336.     return result;
  1337. }
  1338.  
  1339. /*
  1340.  *----------------------------------------------------------------------
  1341.  *
  1342.  * DupDoubleInternalRep --
  1343.  *
  1344.  *    Initialize the internal representation of a double Tcl_Obj to a
  1345.  *    copy of the internal representation of an existing double object. 
  1346.  *
  1347.  * Results:
  1348.  *    None.
  1349.  *
  1350.  * Side effects:
  1351.  *    "copyPtr"s internal rep is set to the double precision floating 
  1352.  *    point number corresponding to "srcPtr"s internal rep.
  1353.  *
  1354.  *----------------------------------------------------------------------
  1355.  */
  1356.  
  1357. static void
  1358. DupDoubleInternalRep(srcPtr, copyPtr)
  1359.     register Tcl_Obj *srcPtr;    /* Object with internal rep to copy. */
  1360.     register Tcl_Obj *copyPtr;    /* Object with internal rep to set. */
  1361. {
  1362.     copyPtr->internalRep.doubleValue = srcPtr->internalRep.doubleValue;
  1363.     copyPtr->typePtr = &tclDoubleType;
  1364. }
  1365.  
  1366. /*
  1367.  *----------------------------------------------------------------------
  1368.  *
  1369.  * SetDoubleFromAny --
  1370.  *
  1371.  *    Attempt to generate an double-precision floating point internal form
  1372.  *    for the Tcl object "objPtr".
  1373.  *
  1374.  * Results:
  1375.  *    The return value is a standard Tcl object result. If an error occurs
  1376.  *    during conversion, an error message is left in the interpreter's
  1377.  *    result unless "interp" is NULL.
  1378.  *
  1379.  * Side effects:
  1380.  *    If no error occurs, a double is stored as "objPtr"s internal
  1381.  *    representation.
  1382.  *
  1383.  *----------------------------------------------------------------------
  1384.  */
  1385.  
  1386. static int
  1387. SetDoubleFromAny(interp, objPtr)
  1388.     Tcl_Interp *interp;        /* Used for error reporting if not NULL. */
  1389.     register Tcl_Obj *objPtr;    /* The object to convert. */
  1390. {
  1391.     Tcl_ObjType *oldTypePtr = objPtr->typePtr;
  1392.     char *string, *end;
  1393.     double newDouble;
  1394.     int length;
  1395.  
  1396.     /*
  1397.      * Get the string representation. Make it up-to-date if necessary.
  1398.      */
  1399.  
  1400.     string = TclGetStringFromObj(objPtr, &length);
  1401.  
  1402.     /*
  1403.      * Now parse "objPtr"s string as an double. Numbers can't have embedded
  1404.      * NULLs. We use an implementation here that doesn't report errors in
  1405.      * interp if interp is NULL.
  1406.      */
  1407.  
  1408.     errno = 0;
  1409.     newDouble = strtod(string, &end);
  1410.     if (end == string) {
  1411.     badDouble:
  1412.     if (interp != NULL) {
  1413.         /*
  1414.          * Must copy string before resetting the result in case a caller
  1415.          * is trying to convert the interpreter's result to an int.
  1416.          */
  1417.         
  1418.         char buf[100];
  1419.         sprintf(buf, "expected floating-point number but got \"%.50s\"",
  1420.                 string);
  1421.         Tcl_ResetResult(interp);
  1422.         Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
  1423.     }
  1424.     return TCL_ERROR;
  1425.     }
  1426.     if (errno != 0) {
  1427.     if (interp != NULL) {
  1428.         TclExprFloatError(interp, newDouble);
  1429.     }
  1430.     return TCL_ERROR;
  1431.     }
  1432.  
  1433.     /*
  1434.      * Make sure that the string has no garbage after the end of the double.
  1435.      */
  1436.     
  1437.     while ((end < (string+length)) && isspace(UCHAR(*end))) {
  1438.     end++;
  1439.     }
  1440.     if (end != (string+length)) {
  1441.     goto badDouble;
  1442.     }
  1443.     
  1444.     /*
  1445.      * The conversion to double succeeded. Free the old internalRep before
  1446.      * setting the new one. We do this as late as possible to allow the
  1447.      * conversion code, in particular Tcl_GetStringFromObj, to use that old
  1448.      * internalRep.
  1449.      */
  1450.     
  1451.     if ((oldTypePtr != NULL) &&    (oldTypePtr->freeIntRepProc != NULL)) {
  1452.     oldTypePtr->freeIntRepProc(objPtr);
  1453.     }
  1454.  
  1455.     objPtr->internalRep.doubleValue = newDouble;
  1456.     objPtr->typePtr = &tclDoubleType;
  1457.     return TCL_OK;
  1458. }
  1459.  
  1460. /*
  1461.  *----------------------------------------------------------------------
  1462.  *
  1463.  * UpdateStringOfDouble --
  1464.  *
  1465.  *    Update the string representation for a double-precision floating
  1466.  *    point object. This must obey the current tcl_precision value for
  1467.  *    double-to-string conversions. Note: This procedure does not free an
  1468.  *    existing old string rep so storage will be lost if this has not
  1469.  *    already been done.
  1470.  *
  1471.  * Results:
  1472.  *    None.
  1473.  *
  1474.  * Side effects:
  1475.  *    The object's string is set to a valid string that results from
  1476.  *    the double-to-string conversion.
  1477.  *
  1478.  *----------------------------------------------------------------------
  1479.  */
  1480.  
  1481. static void
  1482. UpdateStringOfDouble(objPtr)
  1483.     register Tcl_Obj *objPtr;    /* Double obj with string rep to update. */
  1484. {
  1485.     char buffer[TCL_DOUBLE_SPACE];
  1486.     register int len;
  1487.     
  1488.     Tcl_PrintDouble((Tcl_Interp *) NULL, objPtr->internalRep.doubleValue,
  1489.         buffer);
  1490.     len = strlen(buffer);
  1491.     
  1492.     objPtr->bytes = (char *) ckalloc((unsigned) len + 1);
  1493.     strcpy(objPtr->bytes, buffer);
  1494.     objPtr->length = len;
  1495. }
  1496.  
  1497. /*
  1498.  *----------------------------------------------------------------------
  1499.  *
  1500.  * Tcl_NewIntObj --
  1501.  *
  1502.  *    If a client is compiled with TCL_MEM_DEBUG defined, calls to
  1503.  *    Tcl_NewIntObj to create a new integer object end up calling the
  1504.  *    debugging procedure Tcl_DbNewLongObj instead.
  1505.  *
  1506.  *    Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
  1507.  *    calls to Tcl_NewIntObj result in a call to one of the two
  1508.  *    Tcl_NewIntObj implementations below. We provide two implementations
  1509.  *    so that the Tcl core can be compiled to do memory debugging of the 
  1510.  *    core even if a client does not request it for itself.
  1511.  *
  1512.  *    Integer and long integer objects share the same "integer" type
  1513.  *    implementation. We store all integers as longs and Tcl_GetIntFromObj
  1514.  *    checks whether the current value of the long can be represented by
  1515.  *    an int.
  1516.  *
  1517.  * Results:
  1518.  *    The newly created object is returned. This object will have an
  1519.  *    invalid string representation. The returned object has ref count 0.
  1520.  *
  1521.  * Side effects:
  1522.  *    None.
  1523.  *
  1524.  *----------------------------------------------------------------------
  1525.  */
  1526.  
  1527. #ifdef TCL_MEM_DEBUG
  1528. #undef Tcl_NewIntObj
  1529.  
  1530. Tcl_Obj *
  1531. Tcl_NewIntObj(intValue)
  1532.     register int intValue;    /* Int used to initialize the new object. */
  1533. {
  1534.     return Tcl_DbNewLongObj((long)intValue, "unknown", 0);
  1535. }
  1536.  
  1537. #else /* if not TCL_MEM_DEBUG */
  1538.  
  1539. Tcl_Obj *
  1540. Tcl_NewIntObj(intValue)
  1541.     register int intValue;    /* Int used to initialize the new object. */
  1542. {
  1543.     register Tcl_Obj *objPtr;
  1544.  
  1545.     TclNewObj(objPtr);
  1546.     objPtr->bytes = NULL;
  1547.     
  1548.     objPtr->internalRep.longValue = (long)intValue;
  1549.     objPtr->typePtr = &tclIntType;
  1550.     return objPtr;
  1551. }
  1552. #endif /* if TCL_MEM_DEBUG */
  1553.  
  1554. /*
  1555.  *----------------------------------------------------------------------
  1556.  *
  1557.  * Tcl_SetIntObj --
  1558.  *
  1559.  *    Modify an object to be an integer and to have the specified integer
  1560.  *    value.
  1561.  *
  1562.  * Results:
  1563.  *    None.
  1564.  *
  1565.  * Side effects:
  1566.  *    The object's old string rep, if any, is freed. Also, any old
  1567.  *    internal rep is freed. 
  1568.  *
  1569.  *----------------------------------------------------------------------
  1570.  */
  1571.  
  1572. void
  1573. Tcl_SetIntObj(objPtr, intValue)
  1574.     register Tcl_Obj *objPtr;    /* Object whose internal rep to init. */
  1575.     register int intValue;    /* Integer used to set object's value. */
  1576. {
  1577.     register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
  1578.  
  1579.     if (Tcl_IsShared(objPtr)) {
  1580.     panic("Tcl_SetIntObj called with shared object");
  1581.     }
  1582.     
  1583.     Tcl_InvalidateStringRep(objPtr);
  1584.     if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
  1585.     oldTypePtr->freeIntRepProc(objPtr);
  1586.     }
  1587.     
  1588.     objPtr->internalRep.longValue = (long) intValue;
  1589.     objPtr->typePtr = &tclIntType;
  1590. }
  1591.  
  1592. /*
  1593.  *----------------------------------------------------------------------
  1594.  *
  1595.  * Tcl_GetIntFromObj --
  1596.  *
  1597.  *    Attempt to return an int from the Tcl object "objPtr". If the object
  1598.  *    is not already an int, an attempt will be made to convert it to one.
  1599.  *
  1600.  *    Integer and long integer objects share the same "integer" type
  1601.  *    implementation. We store all integers as longs and Tcl_GetIntFromObj
  1602.  *    checks whether the current value of the long can be represented by
  1603.  *    an int.
  1604.  *
  1605.  * Results:
  1606.  *    The return value is a standard Tcl object result. If an error occurs
  1607.  *    during conversion or if the long integer held by the object
  1608.  *    can not be represented by an int, an error message is left in
  1609.  *    the interpreter's result unless "interp" is NULL.
  1610.  *
  1611.  * Side effects:
  1612.  *    If the object is not already an int, the conversion will free
  1613.  *    any old internal representation.
  1614.  *
  1615.  *----------------------------------------------------------------------
  1616.  */
  1617.  
  1618. int
  1619. Tcl_GetIntFromObj(interp, objPtr, intPtr)
  1620.     Tcl_Interp *interp;     /* Used for error reporting if not NULL. */
  1621.     register Tcl_Obj *objPtr;    /* The object from which to get a int. */
  1622.     register int *intPtr;    /* Place to store resulting int. */
  1623. {
  1624.     register long l;
  1625.     int result;
  1626.     
  1627.     if (objPtr->typePtr != &tclIntType) {
  1628.     result = SetIntFromAny(interp, objPtr);
  1629.     if (result != TCL_OK) {
  1630.         return result;
  1631.     }
  1632.     }
  1633.     l = objPtr->internalRep.longValue;
  1634.     if (((long)((int)l)) == l) {
  1635.     *intPtr = (int)objPtr->internalRep.longValue;
  1636.     return TCL_OK;
  1637.     }
  1638.     if (interp != NULL) {
  1639.     Tcl_ResetResult(interp);
  1640.     Tcl_AppendToObj(Tcl_GetObjResult(interp),
  1641.         "integer value too large to represent as non-long integer", -1);
  1642.     }
  1643.     return TCL_ERROR;
  1644. }
  1645.  
  1646. /*
  1647.  *----------------------------------------------------------------------
  1648.  *
  1649.  * DupIntInternalRep --
  1650.  *
  1651.  *    Initialize the internal representation of an int Tcl_Obj to a
  1652.  *    copy of the internal representation of an existing int object. 
  1653.  *
  1654.  * Results:
  1655.  *    None.
  1656.  *
  1657.  * Side effects:
  1658.  *    "copyPtr"s internal rep is set to the integer corresponding to
  1659.  *    "srcPtr"s internal rep.
  1660.  *
  1661.  *----------------------------------------------------------------------
  1662.  */
  1663.  
  1664. static void
  1665. DupIntInternalRep(srcPtr, copyPtr)
  1666.     register Tcl_Obj *srcPtr;    /* Object with internal rep to copy. */
  1667.     register Tcl_Obj *copyPtr;    /* Object with internal rep to set. */
  1668. {
  1669.     copyPtr->internalRep.longValue = srcPtr->internalRep.longValue;
  1670.     copyPtr->typePtr = &tclIntType;
  1671. }
  1672.  
  1673. /*
  1674.  *----------------------------------------------------------------------
  1675.  *
  1676.  * SetIntFromAny --
  1677.  *
  1678.  *    Attempt to generate an integer internal form for the Tcl object
  1679.  *    "objPtr".
  1680.  *
  1681.  * Results:
  1682.  *    The return value is a standard object Tcl result. If an error occurs
  1683.  *    during conversion, an error message is left in the interpreter's
  1684.  *    result unless "interp" is NULL.
  1685.  *
  1686.  * Side effects:
  1687.  *    If no error occurs, an int is stored as "objPtr"s internal
  1688.  *    representation. 
  1689.  *
  1690.  *----------------------------------------------------------------------
  1691.  */
  1692.  
  1693. static int
  1694. SetIntFromAny(interp, objPtr)
  1695.     Tcl_Interp *interp;        /* Used for error reporting if not NULL. */
  1696.     register Tcl_Obj *objPtr;    /* The object to convert. */
  1697. {
  1698.     Tcl_ObjType *oldTypePtr = objPtr->typePtr;
  1699.     char *string, *end;
  1700.     int length;
  1701.     register char *p;
  1702.     long newLong;
  1703.  
  1704.     /*
  1705.      * Get the string representation. Make it up-to-date if necessary.
  1706.      */
  1707.  
  1708.     string = TclGetStringFromObj(objPtr, &length);
  1709.  
  1710.     /*
  1711.      * Now parse "objPtr"s string as an int. We use an implementation here
  1712.      * that doesn't report errors in interp if interp is NULL. Note: use
  1713.      * strtoul instead of strtol for integer conversions to allow full-size
  1714.      * unsigned numbers, but don't depend on strtoul to handle sign
  1715.      * characters; it won't in some implementations.
  1716.      */
  1717.  
  1718.     errno = 0;
  1719.     for (p = string;  isspace(UCHAR(*p));  p++) {
  1720.     /* Empty loop body. */
  1721.     }
  1722.     if (*p == '-') {
  1723.     p++;
  1724.     newLong = -((long)strtoul(p, &end, 0));
  1725.     } else if (*p == '+') {
  1726.     p++;
  1727.     newLong = strtoul(p, &end, 0);
  1728.     } else {
  1729.     newLong = strtoul(p, &end, 0);
  1730.     }
  1731.     if (end == p) {
  1732.     badInteger:
  1733.     if (interp != NULL) {
  1734.         /*
  1735.          * Must copy string before resetting the result in case a caller
  1736.          * is trying to convert the interpreter's result to an int.
  1737.          */
  1738.         
  1739.         char buf[100];
  1740.         sprintf(buf, "expected integer but got \"%.50s\"", string);
  1741.         Tcl_ResetResult(interp);
  1742.         Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
  1743.     }
  1744.     return TCL_ERROR;
  1745.     }
  1746.     if (errno == ERANGE) {
  1747.     if (interp != NULL) {
  1748.         char *s = "integer value too large to represent";
  1749.         Tcl_ResetResult(interp);
  1750.         Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
  1751.         Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
  1752.     }
  1753.     return TCL_ERROR;
  1754.     }
  1755.  
  1756.     /*
  1757.      * Make sure that the string has no garbage after the end of the int.
  1758.      */
  1759.     
  1760.     while ((end < (string+length)) && isspace(UCHAR(*end))) {
  1761.     end++;
  1762.     }
  1763.     if (end != (string+length)) {
  1764.     goto badInteger;
  1765.     }
  1766.  
  1767.     /*
  1768.      * The conversion to int succeeded. Free the old internalRep before
  1769.      * setting the new one. We do this as late as possible to allow the
  1770.      * conversion code, in particular Tcl_GetStringFromObj, to use that old
  1771.      * internalRep.
  1772.      */
  1773.  
  1774.     if ((oldTypePtr != NULL) &&    (oldTypePtr->freeIntRepProc != NULL)) {
  1775.     oldTypePtr->freeIntRepProc(objPtr);
  1776.     }
  1777.     
  1778.     objPtr->internalRep.longValue = newLong;
  1779.     objPtr->typePtr = &tclIntType;
  1780.     return TCL_OK;
  1781. }
  1782.  
  1783. /*
  1784.  *----------------------------------------------------------------------
  1785.  *
  1786.  * UpdateStringOfInt --
  1787.  *
  1788.  *    Update the string representation for an integer object.
  1789.  *    Note: This procedure does not free an existing old string rep
  1790.  *    so storage will be lost if this has not already been done. 
  1791.  *
  1792.  * Results:
  1793.  *    None.
  1794.  *
  1795.  * Side effects:
  1796.  *    The object's string is set to a valid string that results from
  1797.  *    the int-to-string conversion.
  1798.  *
  1799.  *----------------------------------------------------------------------
  1800.  */
  1801.  
  1802. static void
  1803. UpdateStringOfInt(objPtr)
  1804.     register Tcl_Obj *objPtr;    /* Int object whose string rep to update. */
  1805. {
  1806.     char buffer[TCL_DOUBLE_SPACE];
  1807.     register int len;
  1808.     
  1809.     len = TclFormatInt(buffer, objPtr->internalRep.longValue);
  1810.     
  1811.     objPtr->bytes = ckalloc((unsigned) len + 1);
  1812.     strcpy(objPtr->bytes, buffer);
  1813.     objPtr->length = len;
  1814. }
  1815.  
  1816. /*
  1817.  *----------------------------------------------------------------------
  1818.  *
  1819.  * Tcl_NewLongObj --
  1820.  *
  1821.  *    If a client is compiled with TCL_MEM_DEBUG defined, calls to
  1822.  *    Tcl_NewLongObj to create a new long integer object end up calling
  1823.  *    the debugging procedure Tcl_DbNewLongObj instead.
  1824.  *
  1825.  *    Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
  1826.  *    calls to Tcl_NewLongObj result in a call to one of the two
  1827.  *    Tcl_NewLongObj implementations below. We provide two implementations
  1828.  *    so that the Tcl core can be compiled to do memory debugging of the 
  1829.  *    core even if a client does not request it for itself.
  1830.  *
  1831.  *    Integer and long integer objects share the same "integer" type
  1832.  *    implementation. We store all integers as longs and Tcl_GetIntFromObj
  1833.  *    checks whether the current value of the long can be represented by
  1834.  *    an int.
  1835.  *
  1836.  * Results:
  1837.  *    The newly created object is returned. This object will have an
  1838.  *    invalid string representation. The returned object has ref count 0.
  1839.  *
  1840.  * Side effects:
  1841.  *    None.
  1842.  *
  1843.  *----------------------------------------------------------------------
  1844.  */
  1845.  
  1846. #ifdef TCL_MEM_DEBUG
  1847. #undef Tcl_NewLongObj
  1848.  
  1849. Tcl_Obj *
  1850. Tcl_NewLongObj(longValue)
  1851.     register long longValue;    /* Long integer used to initialize the
  1852.                  * new object. */
  1853. {
  1854.     return Tcl_DbNewLongObj(longValue, "unknown", 0);
  1855. }
  1856.  
  1857. #else /* if not TCL_MEM_DEBUG */
  1858.  
  1859. Tcl_Obj *
  1860. Tcl_NewLongObj(longValue)
  1861.     register long longValue;    /* Long integer used to initialize the
  1862.                  * new object. */
  1863. {
  1864.     register Tcl_Obj *objPtr;
  1865.  
  1866.     TclNewObj(objPtr);
  1867.     objPtr->bytes = NULL;
  1868.     
  1869.     objPtr->internalRep.longValue = longValue;
  1870.     objPtr->typePtr = &tclIntType;
  1871.     return objPtr;
  1872. }
  1873. #endif /* if TCL_MEM_DEBUG */
  1874.  
  1875. /*
  1876.  *----------------------------------------------------------------------
  1877.  *
  1878.  * Tcl_DbNewLongObj --
  1879.  *
  1880.  *    If a client is compiled with TCL_MEM_DEBUG defined, calls to
  1881.  *    Tcl_NewIntObj and Tcl_NewLongObj to create new integer or
  1882.  *    long integer objects end up calling the debugging procedure
  1883.  *    Tcl_DbNewLongObj instead. We provide two implementations of
  1884.  *    Tcl_DbNewLongObj so that whether the Tcl core is compiled to do
  1885.  *    memory debugging of the core is independent of whether a client
  1886.  *    requests debugging for itself.
  1887.  *
  1888.  *    When the core is compiled with TCL_MEM_DEBUG defined,
  1889.  *    Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and
  1890.  *    line number from its caller. This simplifies debugging since then
  1891.  *    the checkmem command will report the caller's file name and line
  1892.  *    number when reporting objects that haven't been freed.
  1893.  *
  1894.  *    Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
  1895.  *    this procedure just returns the result of calling Tcl_NewLongObj.
  1896.  *
  1897.  * Results:
  1898.  *    The newly created long integer object is returned. This object
  1899.  *    will have an invalid string representation. The returned object has
  1900.  *    ref count 0.
  1901.  *
  1902.  * Side effects:
  1903.  *    Allocates memory.
  1904.  *
  1905.  *----------------------------------------------------------------------
  1906.  */
  1907.  
  1908. #ifdef TCL_MEM_DEBUG
  1909.  
  1910. Tcl_Obj *
  1911. Tcl_DbNewLongObj(longValue, file, line)
  1912.     register long longValue;    /* Long integer used to initialize the
  1913.                  * new object. */
  1914.     char *file;            /* The name of the source file calling this
  1915.                  * procedure; used for debugging. */
  1916.     int line;            /* Line number in the source file; used
  1917.                  * for debugging. */
  1918. {
  1919.     register Tcl_Obj *objPtr;
  1920.  
  1921.     TclDbNewObj(objPtr, file, line);
  1922.     objPtr->bytes = NULL;
  1923.     
  1924.     objPtr->internalRep.longValue = longValue;
  1925.     objPtr->typePtr = &tclIntType;
  1926.     return objPtr;
  1927. }
  1928.  
  1929. #else /* if not TCL_MEM_DEBUG */
  1930.  
  1931. Tcl_Obj *
  1932. Tcl_DbNewLongObj(longValue, file, line)
  1933.     register long longValue;    /* Long integer used to initialize the
  1934.                  * new object. */
  1935.     char *file;            /* The name of the source file calling this
  1936.                  * procedure; used for debugging. */
  1937.     int line;            /* Line number in the source file; used
  1938.                  * for debugging. */
  1939. {
  1940.     return Tcl_NewLongObj(longValue);
  1941. }
  1942. #endif /* TCL_MEM_DEBUG */
  1943.  
  1944. /*
  1945.  *----------------------------------------------------------------------
  1946.  *
  1947.  * Tcl_SetLongObj --
  1948.  *
  1949.  *    Modify an object to be an integer object and to have the specified
  1950.  *    long integer value.
  1951.  *
  1952.  * Results:
  1953.  *    None.
  1954.  *
  1955.  * Side effects:
  1956.  *    The object's old string rep, if any, is freed. Also, any old
  1957.  *    internal rep is freed. 
  1958.  *
  1959.  *----------------------------------------------------------------------
  1960.  */
  1961.  
  1962. void
  1963. Tcl_SetLongObj(objPtr, longValue)
  1964.     register Tcl_Obj *objPtr;    /* Object whose internal rep to init. */
  1965.     register long longValue;    /* Long integer used to initialize the
  1966.                  * object's value. */
  1967. {
  1968.     register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
  1969.  
  1970.     if (Tcl_IsShared(objPtr)) {
  1971.     panic("Tcl_SetLongObj called with shared object");
  1972.     }
  1973.  
  1974.     Tcl_InvalidateStringRep(objPtr);
  1975.     if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
  1976.     oldTypePtr->freeIntRepProc(objPtr);
  1977.     }
  1978.     
  1979.     objPtr->internalRep.longValue = longValue;
  1980.     objPtr->typePtr = &tclIntType;
  1981. }
  1982.  
  1983. /*
  1984.  *----------------------------------------------------------------------
  1985.  *
  1986.  * Tcl_GetLongFromObj --
  1987.  *
  1988.  *    Attempt to return an long integer from the Tcl object "objPtr". If
  1989.  *    the object is not already an int object, an attempt will be made to
  1990.  *    convert it to one.
  1991.  *
  1992.  * Results:
  1993.  *    The return value is a standard Tcl object result. If an error occurs
  1994.  *    during conversion, an error message is left in the interpreter's
  1995.  *    result unless "interp" is NULL.
  1996.  *
  1997.  * Side effects:
  1998.  *    If the object is not already an int object, the conversion will free
  1999.  *    any old internal representation.
  2000.  *
  2001.  *----------------------------------------------------------------------
  2002.  */
  2003.  
  2004. int
  2005. Tcl_GetLongFromObj(interp, objPtr, longPtr)
  2006.     Tcl_Interp *interp;     /* Used for error reporting if not NULL. */
  2007.     register Tcl_Obj *objPtr;    /* The object from which to get a long. */
  2008.     register long *longPtr;    /* Place to store resulting long. */
  2009. {
  2010.     register int result;
  2011.     
  2012.     if (objPtr->typePtr == &tclIntType) {
  2013.     *longPtr = objPtr->internalRep.longValue;
  2014.     return TCL_OK;
  2015.     }
  2016.     result = SetIntFromAny(interp, objPtr);
  2017.     if (result == TCL_OK) {
  2018.     *longPtr = objPtr->internalRep.longValue;
  2019.     }
  2020.     return result;
  2021. }
  2022.  
  2023. /*
  2024.  *----------------------------------------------------------------------
  2025.  *
  2026.  * Tcl_DbIncrRefCount --
  2027.  *
  2028.  *    This procedure is normally called when debugging: i.e., when
  2029.  *    TCL_MEM_DEBUG is defined. This checks to see whether or not
  2030.  *    the memory has been freed before incrementing the ref count.
  2031.  *
  2032.  *    When TCL_MEM_DEBUG is not defined, this procedure just increments
  2033.  *    the reference count of the object.
  2034.  *
  2035.  * Results:
  2036.  *    None.
  2037.  *
  2038.  * Side effects:
  2039.  *    The object's ref count is incremented.
  2040.  *
  2041.  *----------------------------------------------------------------------
  2042.  */
  2043.  
  2044. void
  2045. Tcl_DbIncrRefCount(objPtr, file, line)
  2046.     register Tcl_Obj *objPtr;    /* The object we are adding a reference to. */
  2047.     char *file;            /* The name of the source file calling this
  2048.                  * procedure; used for debugging. */
  2049.     int line;            /* Line number in the source file; used
  2050.                  * for debugging. */
  2051. {
  2052. #ifdef TCL_MEM_DEBUG
  2053.     if (objPtr->refCount == 0x61616161) {
  2054.     fprintf(stderr, "file = %s, line = %d\n", file, line);
  2055.     fflush(stderr);
  2056.     panic("Trying to increment refCount of previously disposed object.");
  2057.     }
  2058. #endif
  2059.     ++(objPtr)->refCount;
  2060. }
  2061.  
  2062. /*
  2063.  *----------------------------------------------------------------------
  2064.  *
  2065.  * Tcl_DbDecrRefCount --
  2066.  *
  2067.  *    This procedure is normally called when debugging: i.e., when
  2068.  *    TCL_MEM_DEBUG is defined. This checks to see whether or not
  2069.  *    the memory has been freed before incrementing the ref count.
  2070.  *
  2071.  *    When TCL_MEM_DEBUG is not defined, this procedure just increments
  2072.  *    the reference count of the object.
  2073.  *
  2074.  * Results:
  2075.  *    None.
  2076.  *
  2077.  * Side effects:
  2078.  *    The object's ref count is incremented.
  2079.  *
  2080.  *----------------------------------------------------------------------
  2081.  */
  2082.  
  2083. void
  2084. Tcl_DbDecrRefCount(objPtr, file, line)
  2085.     register Tcl_Obj *objPtr;    /* The object we are adding a reference to. */
  2086.     char *file;            /* The name of the source file calling this
  2087.                  * procedure; used for debugging. */
  2088.     int line;            /* Line number in the source file; used
  2089.                  * for debugging. */
  2090. {
  2091. #ifdef TCL_MEM_DEBUG
  2092.     if (objPtr->refCount == 0x61616161) {
  2093.     fprintf(stderr, "file = %s, line = %d\n", file, line);
  2094.     fflush(stderr);
  2095.     panic("Trying to increment refCount of previously disposed object.");
  2096.     }
  2097. #endif
  2098.     if (--(objPtr)->refCount <= 0) {
  2099.     TclFreeObj(objPtr);
  2100.     }
  2101. }
  2102.  
  2103. /*
  2104.  *----------------------------------------------------------------------
  2105.  *
  2106.  * Tcl_DbIsShared --
  2107.  *
  2108.  *    This procedure is normally called when debugging: i.e., when
  2109.  *    TCL_MEM_DEBUG is defined. This checks to see whether or not
  2110.  *    the memory has been freed before incrementing the ref count.
  2111.  *
  2112.  *    When TCL_MEM_DEBUG is not defined, this procedure just decrements
  2113.  *    the reference count of the object and throws it away if the count
  2114.  *    is 0 or less.
  2115.  *
  2116.  * Results:
  2117.  *    None.
  2118.  *
  2119.  * Side effects:
  2120.  *    The object's ref count is incremented.
  2121.  *
  2122.  *----------------------------------------------------------------------
  2123.  */
  2124.  
  2125. int
  2126. Tcl_DbIsShared(objPtr, file, line)
  2127.     register Tcl_Obj *objPtr;    /* The object we are adding a reference to. */
  2128.     char *file;            /* The name of the source file calling this
  2129.                  * procedure; used for debugging. */
  2130.     int line;            /* Line number in the source file; used
  2131.                  * for debugging. */
  2132. {
  2133. #ifdef TCL_MEM_DEBUG
  2134.     if (objPtr->refCount == 0x61616161) {
  2135.     fprintf(stderr, "file = %s, line = %d\n", file, line);
  2136.     fflush(stderr);
  2137.     panic("Trying to increment refCount of previously disposed object.");
  2138.     }
  2139. #endif
  2140.     return ((objPtr)->refCount > 1);
  2141. }
  2142.